home *** CD-ROM | disk | FTP | other *** search
/ Graphics Plus / Graphics Plus.iso / libs / phigs / ptk.lha / ptk / fortran / source / library / tran.f < prev    next >
Encoding:
Text File  |  1992-06-18  |  51.4 KB  |  1,659 lines
  1.  
  2.         LOGICAL FUNCTION ptkf_equal(one, two)
  3. C /*
  4. C ** \parambegin
  5. C ** \param{REAL}{one}{floating point number}{IN}
  6. C ** \param{REAL}{two}{floating point number}{IN}
  7. C ** \paramend
  8. C ** \blurb{This function returns TRUE if \pardesc{one} and \pardesc{two}
  9. C ** are equal, or their difference is less than the global 
  10. C ** constant tolerance \pardesc{ptkcpceps}.}
  11. C */
  12.         REAL one, two
  13.         REAL*8 dpone, dptwo
  14.         BYTE ans
  15.         LOGICAL *1 ptk_equal
  16.         external ptk_equal !$PRAGMA C(ptk_equal)
  17.  
  18.         dpone = one
  19.         dptwo = two
  20.         ans = ptk_equal(%val(dpone), %val(dptwo))
  21.         if (ans .eq. 1) then
  22.                 ptkf_equal = .TRUE.
  23.         else
  24.                 ptkf_equal = .FALSE.
  25.         endif
  26.  
  27.         RETURN
  28.         END
  29.  
  30.         SUBROUTINE ptkf_point(x, y, pt)
  31. C /*
  32. C ** \parambegin
  33. C ** \param{REAL}{x}{x coordinate}{IN}
  34. C ** \param{REAL}{y}{y coordinate}{IN}
  35. C ** \param{REAL}{pt(2)}{real array}{OUT}
  36. C ** \paramend
  37. C ** \blurb{This function puts the values \pardesc{(x,y)} in the
  38. C ** array {\tt pt}.}
  39. C */
  40.         REAL x, y, pt(2)
  41.         pt(1) = x
  42.         pt(2) = y
  43.  
  44.         RETURN
  45.         END
  46.         
  47.         SUBROUTINE ptkf_point3(x, y, z, pt)
  48. C /*
  49. C ** \parambegin
  50. C ** \param{REAL}{x}{x coordinate}{IN}
  51. C ** \param{REAL}{y}{y coordinate}{IN}
  52. C ** \param{REAL}{z}{z coordinate}{IN}
  53. C ** \param{REAL}{pt(3)}{real array}{OUT}
  54. C ** \paramend
  55. C ** \blurb{This function puts the values \pardesc{(x,y,z)} in the
  56. C ** array {\tt pt}.}
  57. C */
  58.         REAL x, y, z, pt(3)
  59.         
  60.         pt(1) = x
  61.         pt(2) = y
  62.         pt(3) = z
  63.  
  64.         RETURN
  65.         END
  66.         
  67.         SUBROUTINE ptkf_limit(xmin, xmax, ymin, ymax, lt)
  68. C /*
  69. C ** \parambegin
  70. C ** \param{REAL}{xmin}{minimum x coordinate}{IN}
  71. C ** \param{REAL}{xmax}{maximum x coordinate}{IN}
  72. C ** \param{REAL}{ymin}{minimum y coordinate}{IN}
  73. C ** \param{REAL}{ymax}{maximum y coordinate}{IN}
  74. C ** \param{REAL}{lt(4)}{real array}{OUT}
  75. C ** \paramend
  76. C ** \blurb{This function puts the values \pardesc{(xmin,xmax,ymin,ymax)} 
  77. C ** in the array {\tt lt}.}
  78. C */
  79.         REAL xmin, xmax, ymin, ymax, lt(4)
  80.         
  81.         lt(1) = xmin
  82.         lt(2) = xmax
  83.         lt(3) = ymin
  84.         lt(4) = ymax
  85.  
  86.         RETURN
  87.         END
  88.         
  89.         SUBROUTINE ptkf_limit3(xmin, xmax, ymin, ymax, zmin, zmax, lt)
  90. C /*
  91. C ** \parambegin
  92. C ** \param{REAL}{xmin}{minimum x coordinate}{IN}
  93. C ** \param{REAL}{xmax}{maximum x coordinate}{IN}
  94. C ** \param{REAL}{ymin}{minimum y coordinate}{IN}
  95. C ** \param{REAL}{ymax}{maximum y coordinate}{IN}
  96. C ** \param{REAL}{zmin}{minimum z coordinate}{IN}
  97. C ** \param{REAL}{zmax}{maximum z coordinate}{IN}
  98. C ** \param{REAL}{lt(6)}{real array}{OUT}
  99. C ** \paramend
  100. C ** \blurb{This function puts the values 
  101. C ** \pardesc{(xmin,xmax,ymin,ymax,zmin,zmax)} 
  102. C ** in the array {\tt lt}.}
  103. C */
  104.         REAL xmin, xmax, ymin, ymax, zmin, zmax, lt(6)
  105.         
  106.         lt(1) = xmin
  107.         lt(2) = xmax
  108.         lt(3) = ymin
  109.         lt(4) = ymax
  110.         lt(5) = zmin
  111.         lt(6) = zmax
  112.  
  113.         RETURN
  114.         END
  115.  
  116.         REAL FUNCTION ptkf_dotv3(v1, v2)
  117. C /*
  118. C ** \parambegin
  119. C ** \param{REAL}{v1(3)}{3D vector}{IN}
  120. C ** \param{REAL}{v2(3)}{3D vector}{IN}
  121. C ** \paramend
  122. C ** \blurb{This function evaluates the dot product of the
  123. C **  two 3D vectors \pardesc{v1} and 
  124. C ** \pardesc{v2}, returning it as the value of the function.}
  125. C */
  126.         REAL v1(3), v2(3)
  127.         REAL ptk_dotv3
  128.         external ptk_dotv3 !$PRAGMA C(ptk_dotv3)
  129.  
  130.         ptkf_dotv3 = ptk_dotv3(v1, v2)
  131.  
  132.         RETURN
  133.         END
  134.  
  135.         REAL FUNCTION ptkf_dotv(v1, v2)
  136. C /*
  137. C ** \parambegin
  138. C ** \param{REAL}{v1(2)}{2D vector}{IN}
  139. C ** \param{REAL}{v2(2)}{2D vector}{IN}
  140. C ** \paramend
  141. C ** \blurb{Evaluates the dot product of the two 2D vectors \pardesc{v1} and
  142. C ** \pardesc{v2}, returning it as the value of the function.}
  143. C */
  144.         REAL v1(2), v2(2)
  145.         REAL ptk_dotv
  146.         external ptk_dotv !$PRAGMA C(ptk_dotv)
  147.       
  148.         ptkf_dotv = ptk_dotv(v1, v2)
  149.  
  150.         RETURN
  151.         END
  152.  
  153.         SUBROUTINE ptkf_crossv3(v1, v2, v3)
  154. C /*
  155. C ** \parambegin
  156. C ** \param{REAL}{v1(3)}{3D vector}{IN}
  157. C ** \param{REAL}{v2(3)}{3D vector}{IN}
  158. C ** \param{REAL}{v3(3)}{3D vector}{OUT}
  159. C ** \paramend
  160. C ** \blurb{This function evaluates the cross product of
  161. C ** the two 3D vectors \pardesc{v1} and
  162. C ** \pardesc{v2}, returning the new vector as
  163. C ** the function result. Since a local copy is made statements such as
  164. C ** {\tt call ptkf\_crossv(v1, v2, v2)}
  165. C ** will produce the correct answer.}
  166. C */
  167.         REAL v1(3), v2(3), v3(3)
  168.         REAL temp(3)         
  169.  
  170.         temp(1) = v1(2) * v2(3) - v1(3) * v2(2)
  171.         temp(2) = v1(3) * v2(1) - v1(1) * v2(3)
  172.         temp(3) = v1(1) * v2(2) - v1(2) * v2(1)
  173.         v3(1) = temp(1)
  174.         v3(2) = temp(2)
  175.         v3(3) = temp(3)
  176.  
  177.         RETURN
  178.         END
  179.                 
  180.         LOGICAL FUNCTION ptkf_nullv3(vec)
  181. C /*
  182. C ** \parambegin
  183. C ** \param{REAL}{vec(3)}{3D vector}{IN}
  184. C ** \paramend
  185. C ** \blurb{This function returns \pardesc{TRUE} if the modulus
  186. C ** of the 3D vector\pardesc{vec} 
  187. C ** is less than the global tolerance \pardesc{ptkpceps}, otherwise 
  188. C ** \pardesc{FALSE}.}
  189. C */
  190.         REAL vec(3)
  191.         BYTE ans
  192.         LOGICAL *1 ptk_nullv3
  193.         external ptk_nullv3 !$PRAGMA C(ptk_nullv3)
  194.  
  195.         ans = ptk_nullv3(vec)
  196.         if (ans .eq. 1) then
  197.                 ptkf_nullv3 = .TRUE.
  198.         else
  199.                 ptkf_nullv3 = .FALSE.
  200.         endif
  201.         
  202.         RETURN
  203.         END
  204.         
  205.         LOGICAL FUNCTION ptkf_nullv(vec)
  206. C /*
  207. C ** \parambegin
  208. C ** \param{REAL}{vec(2)}{2D vector}{IN}
  209. C ** \paramend
  210. C ** \blurb{This function returns \pardesc{TRUE} if the
  211. C ** modulus of the 2D vector \pardesc{vec} 
  212. C ** is less than the global tolerance \pardesc{ptkpceps}, otherwise 
  213. C ** \pardesc{FALSE}.}
  214. C */
  215.         REAL vec(3)
  216.         BYTE ans
  217.         LOGICAL *1 ptk_nullv
  218.         external ptk_nullv !$PRAGMA C(ptk_nullv)
  219.  
  220.         ans = ptk_nullv(vec)
  221.         if (ans .eq. 1) then
  222.                 ptkf_nullv = .TRUE.
  223.         else
  224.                 ptkf_nullv = .FALSE.
  225.         endif
  226.         
  227.         RETURN
  228.         END
  229.         
  230.         REAL FUNCTION ptkf_modv3(vec)
  231. C /*
  232. C ** \parambegin
  233. C ** \param{REAL}{vec(3)}{3D vector}{IN}
  234. C ** \paramend
  235. C ** \blurb{Returns the modulus of the vector \pardesc{vec}.}
  236. C */
  237.         REAL vec(3)
  238.         REAL ptk_modv3
  239.         external ptk_modv3 !$PRAGMA C(ptk_modv3)
  240.  
  241.         ptkf_modv3 = ptk_modv3(vec)
  242.         
  243.         RETURN
  244.         END
  245.         
  246.         REAL FUNCTION ptkf_modv(vec)
  247. C /*
  248. C ** \parambegin
  249. C ** \param{REAL}{vec(2)}{2D vector}{IN}
  250. C ** \paramend
  251. C ** \blurb{This function returns the modulus of the 2D vector \pardesc{vec}.}
  252. C */
  253.         REAL vec(2)
  254.         REAL ptk_modv
  255.         external ptk_modv !$PRAGMA C(ptk_modv)
  256.         
  257.         ptkf_modv = ptk_modv(vec)
  258.         
  259.         RETURN
  260.         END
  261.         
  262.         SUBROUTINE ptkf_unitv3(vec, uvec)
  263. C /*
  264. C ** \parambegin
  265. C ** \param{REAL}{vec(3)}{3D vector}{IN}
  266. C ** \param{REAL}{uvec(3)}{3D vector}{OUT}
  267. C ** \paramend
  268. C ** \blurb{This function generates and returns a unit
  269. C ** vector in {\tt uvec} from the supplied 3D vector 
  270. C ** \pardesc{vec}.}
  271. C */
  272.         REAL vec(3), uvec(3), modu
  273.         REAL ptkf_modv3
  274.         LOGICAL ptkf_equal
  275.  
  276.         modu = ptkf_modv3(vec)
  277.         if (ptkf_equal(modu, 0.0) .eq. .FALSE.) then
  278.           call ptkf_point3(vec(1) / modu, vec(2) / modu, vec(3) / modu, 
  279. & uvec)
  280.         else 
  281.           call ptkf_point3(0.0, 0.0, 0.0, uvec)
  282.         endif
  283.         
  284.         RETURN
  285.         END
  286.         
  287.         SUBROUTINE ptkf_unitv(vec, uvec)
  288. C /*
  289. C ** \parambegin
  290. C ** \param{REAL}{vec(2)}{2D vector}{IN}
  291. C ** \param{REAL}{uvec(2)}{2D vector}{OUT}
  292. C ** \paramend
  293. C ** \blurb{This function generates and returns a unit vector 
  294. C ** in {\tt uvec} from the supplied 2D vector \pardesc{vec}.}
  295. C */
  296.         REAL vec(2), uvec(2), modu
  297.         REAL ptkf_modv
  298.         LOGICAL ptkf_equal
  299.  
  300.         modu = ptkf_modv(vec)
  301.         if (ptkf_equal(modu, 0.0) .eq. .FALSE.) then
  302.           call ptkf_point(vec(1) / modu, vec(2) / modu, uvec)
  303.         else 
  304.           call ptkf_point(0.0, 0.0, uvec)
  305.         endif        
  306.         
  307.         RETURN
  308.         END
  309.         
  310.         SUBROUTINE ptkf_scalev3(vec, scale, svec)
  311. C /*
  312. C ** \parambegin
  313. C ** \param{REAL}{vec(3)}{3D vector}{IN}
  314. C ** \param{REAL}{scale}{scale factor}{IN}
  315. C ** \param{REAL}{svec(3)}{3D vector}{OUT}
  316. C ** \paramend
  317. C ** \blurb{This function multiplies the 3D vector \pardesc{vec}
  318. C **  by the  scalar \pardesc{scale} and
  319. C ** returns the result in {\tt svec}.}
  320. C */
  321.         REAL vec(3), scale, svec(3)
  322.  
  323.         call ptkf_point3(vec(1) * scale, vec(2) * scale, vec(3) * scale, 
  324. & svec)
  325.        
  326.         RETURN
  327.         END
  328.         
  329.         SUBROUTINE ptkf_scalev(vec, scale, svec)
  330. C /*
  331. C ** \parambegin
  332. C ** \param{REAL}{vec(2)}{2D vector}{IN}
  333. C ** \param{REAL}{scale}{scale factor}{IN}
  334. C ** \param{REAL}{svec(2)}{2D vector}{OUT}
  335. C ** \paramend
  336. C ** \blurb{This function multiplies the 2D vector
  337. C ** \pardesc{vec} by the scalar \pardesc{scale} and
  338. C ** returns the result in {\tt svec}.}
  339. C */
  340.         REAL vec(2), scale, svec(2)
  341.  
  342.         call ptkf_point(vec(1) * scale, vec(2) * scale, svec)
  343.  
  344.         RETURN
  345.         END
  346.         
  347.         SUBROUTINE ptkf_subv3(p1, p2, p3)
  348. C /*
  349. C ** \parambegin
  350. C ** \param{REAL}{p1(3)}{3D vector}{IN}
  351. C ** \param{REAL}{p2(3)}{3D vector}{IN}
  352. C ** \param{REAL}{p3(3)}{3D vector}{OUT}
  353. C ** \paramend
  354. C ** \blurb{This function evaluates the 3D vector \pardesc {p1-p2} and
  355. C ** returns the result in {\tt p3}.}
  356. C */
  357.         REAL p1(3), p2(3), p3(3)
  358.         
  359.         call ptkf_point3(p1(1) - p2(1), p1(2)- p2(2), p1(3) - p2(3), 
  360. & p3)
  361.         
  362.         RETURN
  363.         END
  364.         
  365.         SUBROUTINE ptkf_subv(p1, p2, p3)
  366. C /*
  367. C ** \parambegin
  368. C ** \param{REAL}{p1(2)}{2D vector}{IN}
  369. C ** \param{REAL}{p2(2)}{2D vector}{IN}
  370. C ** \param{REAL}{p3(2)}{2D vector}{OUT}
  371. C ** \paramend
  372. C ** \blurb{This function evaluates the 2D vector \pardesc {p1-p2}
  373. C ** and returns the result in {\tt p3}.}
  374. C */
  375.         REAL p1(2), p2(2), p3(2)
  376.                 
  377.         call ptkf_point(p1(1) - p2(1), p1(2)- p2(2), p3)
  378.  
  379.         RETURN
  380.         END
  381.         
  382.         SUBROUTINE ptkf_addv3(p1, p2, p3)
  383. C /*
  384. C ** \parambegin
  385. C ** \param{REAL}{p1(3)}{3D vector}{IN}
  386. C ** \param{REAL}{p2(3)}{3D vector}{IN}
  387. C ** \param{REAL}{p3(3)}{3D vector}{OUT}
  388. C ** \paramend
  389. C ** \blurb{This function evaluates the 3D vector \pardesc{p1+p3} and 
  390. C ** returns the result in {\tt p3}.}
  391. C */
  392.         REAL p1(3), p2(3), p3(3)
  393.         
  394.         call ptkf_point3(p1(1) + p2(1), p1(2) + p2(2), p1(3) + p2(3), 
  395. & p3)
  396.         
  397.         RETURN
  398.         END
  399.         
  400.         SUBROUTINE ptkf_addv(p1, p2, p3)
  401. C /*
  402. C ** \parambegin
  403. C ** \param{REAL}{p1(2)}{2D vector}{IN}
  404. C ** \param{REAL}{p2(2)}{2D vector}{IN}
  405. C ** \param{REAL}{p3(2)}{2D vector}{OUT}
  406. C ** \paramend
  407. C ** \blurb{This function evaluates the 2D vector \pardesc{p1+p2}
  408. C ** and returns the result in {\tt p3}.}
  409. C */
  410.         REAL p1(2), p2(2), p3(2)
  411.         
  412.         call ptkf_point(p1(1) + p2(1), p1(2) + p2(2), p3)
  413.         
  414.         RETURN
  415.         END
  416.         
  417.         SUBROUTINE ptkf_unitmatrix(matrix)
  418. C /*
  419. C ** \parambegin
  420. C ** \param{REAL}{matrix(3, 3)}{3x3 matrix}{IN}
  421. C ** \paramend
  422. C ** \blurb{This procedure creates a unit $3\times 3$ matrix, and stores 
  423. C ** it in \pardesc{matrix}.}
  424. C */
  425.         REAL matrix(3,3)
  426.         external ptk_unitmatrix !$PRAGMA C(ptk_unitmatrix)
  427.         
  428.         call  ptk_unitmatrix(matrix)
  429.         
  430.         RETURN
  431.         END
  432.         
  433.         SUBROUTINE ptkf_unitmatrix3(matrix)
  434. C /*
  435. C ** \parambegin
  436. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{IN}
  437. C ** \paramend
  438. C ** \blurb{This procedure creates a unit $4\times 4$ matrix, and stores 
  439. C ** it in \pardesc{matrix}.}
  440. C */
  441.         REAL matrix(4,4)
  442.         external ptk_unitmatrix3 !$PRAGMA C(ptk_unitmatrix3)
  443.         
  444.         call  ptk_unitmatrix3 (matrix)
  445.         
  446.         RETURN
  447.         END
  448.                 
  449.         SUBROUTINE ptkf_transposematrix3(matrix, result)
  450. C /*
  451. C ** \parambegin
  452. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{IN}
  453. C ** \param{REAL}{result(4, 4)}{4x4 matrix}{OUT}
  454. C ** \paramend
  455. C ** \blurb{This function transposes \pardesc{matrix}, and returns the result
  456. C ** in \pardesc{result}.
  457. C ** Note that \pardesc{result} can be the same variable
  458. C ** as \pardesc{matrix} since a copy is made 
  459. C ** first.}
  460. C */
  461.         REAL matrix(4,4), result(4,4)
  462.         external ptk_transposematrix3 !$PRAGMA C(ptk_transposematrix3)
  463.         
  464.         call  ptk_transposematrix3(matrix, result)
  465.         
  466.         RETURN
  467.         END
  468.         
  469.         SUBROUTINE ptkf_transposematrix(matrix, result)
  470. C /*
  471. C ** \parambegin
  472. C ** \param{REAL}{matrix(3, 3)}{3x3 matrix}{IN}
  473. C ** \param{REAL}{result(3, 3)}{3x3 matrix}{OUT}
  474. C ** \paramend
  475. C ** \blurb{This function transposes \pardesc{matrix}, and returns the result
  476. C ** in \pardesc{result}.
  477. C ** Note that \pardesc{result} can be the same variable
  478. C ** as \pardesc{matrix} since a copy is made 
  479. C ** first.}
  480. C */
  481.         REAL matrix(3,3), result(3,3)
  482.         external ptk_transposematrix !$PRAGMA C(ptk_transposematrix)
  483.  
  484.         call  ptk_transposematrix(matrix, result)
  485.         
  486.         RETURN
  487.         END
  488.         
  489.         SUBROUTINE ptkf_multiplymatrix3(matrix1, matrix2, result)
  490. C /*
  491. C ** \parambegin
  492. C ** \param{REAL}{matrix1(4, 4)}{4x4 matrix}{IN}
  493. C ** \param{REAL}{matrix2(4, 4)}{4x4 matrix}{IN}
  494. C ** \param{REAL}{result(4, 4)}{4x4 matrix}{OUT}
  495. C ** \paramend
  496. C ** \blurb{This function makes \pardesc{result} the product of
  497. C ** the $4 \times 4$ matrices  \pardesc{matrix1} and
  498. C ** \pardesc{matrix2}, with {\tt result $\leftarrow$ matrix1 * matrix2}.
  499. C ** Note that \pardesc{result} can also be \pardesc{matrix1} or 
  500. C ** \pardesc{matrix2} since a copy is made.}
  501. C */
  502.         REAL matrix1(4,4), matrix2(4,4), result(4,4)
  503.         external ptk_multiplymatrix3 !$PRAGMA C(ptk_multiplymatrix3)
  504.  
  505.         call  ptk_multiplymatrix3(matrix1, matrix2, result)
  506.         
  507.         RETURN
  508.         END
  509.         
  510.         SUBROUTINE ptkf_multiplymatrix(matrix1, matrix2, result)
  511. C /*
  512. C ** \parambegin
  513. C ** \param{REAL}{matrix1(3, 3)}{3x3 matrix}{IN}
  514. C ** \param{REAL}{matrix2(3, 3)}{3x3 matrix}{IN}
  515. C ** \param{REAL}{result(3, 3)}{3x3 matrix}{OUT}
  516. C ** \paramend
  517. C ** \blurb{This function makes \pardesc{result} the product of the
  518. C ** $3 \times 3$ matrices \pardesc{matrix1} and
  519. C ** \pardesc{matrix2}, with {\tt result $\leftarrow$ matrix1 * matrix2}.
  520. C ** Note that \pardesc{result} can also be \pardesc{matrix1} or 
  521. C ** \pardesc{matrix2} since a copy is made.}
  522. C */
  523.         REAL matrix1(3,3), matrix2(3,3), result(3,3)
  524.         external ptk_multiplymatrix !$PRAGMA C(ptk_multiplymatrix)
  525.  
  526.         call  ptk_multiplymatrix(matrix1, matrix2, result)
  527.         
  528.         RETURN
  529.         END
  530.         
  531.         SUBROUTINE ptkf_concatenatematrix3(operation, matrix1, matrix2, 
  532. & result)
  533. C /*
  534. C ** \parambegin
  535. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  536. C ** \param{REAL}{matrix1(4, 4)}{4x4 matrix}{IN}
  537. C ** \param{REAL}{matrix2(4, 4)}{4x4 matrix}{IN}
  538. C ** \param{REAL}{result(4, 4)}{4x4 matrix}{OUT}
  539. C ** \paramend
  540. C ** \blurb{This function concatenates the $4 \times 4$ matrices
  541. C ** \pardesc{matrix1}  and \pardesc{matrix2}
  542. C ** on the basis of \pardesc{operation}.
  543. C ** The result is stored in \pardesc{result}.
  544. C ** Note that \pardesc{result} can also be \pardesc{matrix1} or 
  545. C ** \pardesc{matrix2}
  546. C ** since a copy is made. When \pardesc{operation} is 
  547. C ** \pardesc{preconcatenate}, then 
  548. C ** \pardesc{result $\leftarrow$ matrix2 * matrix1}.
  549. C ** When \pardesc{operation} is \pardesc{postconcatenate}, 
  550. C ** \pardesc{result $\leftarrow$  matrix1 * matrix2}.}
  551. C */
  552.         INTEGER operation
  553.         REAL matrix1(4,4), matrix2(4,4), result(4,4)
  554.         external ptk_concatenatematrix3 
  555. & !$PRAGMA C(ptk_concatenatematrix3)
  556.  
  557.         call  ptk_concatenatematrix3(%val(operation), matrix1, matrix2, 
  558. & result)
  559.          
  560.         RETURN
  561.         END
  562.    
  563.         SUBROUTINE ptkf_concatenatematrix(operation, matrix1, matrix2, 
  564. & result)
  565. C /*
  566. C ** \parambegin
  567. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  568. C ** \param{REAL}{matrix1(3, 3)}{3x3 matrix}{IN}
  569. C ** \param{REAL}{matrix2(3, 3)}{3x3 matrix}{IN}
  570. C ** \param{REAL}{result(3, 3)}{3x3 matrix}{OUT}
  571. C ** \paramend
  572. C ** \blurb{This function concatenates
  573. C ** the $3 \times 3$ matrices \pardesc{matrix1}  and \pardesc{matrix2}
  574. C ** on the basis of \pardesc{operation}.
  575. C ** The result is stored in \pardesc{result}.
  576. C ** Note that \pardesc{result} can also be \pardesc{matrix1} or 
  577. C ** \pardesc{matrix2}
  578. C ** since a copy is made. When \pardesc{operation} is
  579. C ** \pardesc{preconcatenate}, then 
  580. C ** \pardesc{result $\leftarrow$ matrix2 * matrix1}.
  581. C ** When \pardesc{operation} is \pardesc{postconcatenate}, 
  582. C ** \pardesc{result $\leftarrow$ matrix1 * matrix2}.}
  583. C */
  584.         INTEGER operation
  585.         REAL matrix1(3,3), matrix2(3,3), result(3,3)
  586.         external ptk_concatenatematrix !$PRAGMA C(ptk_concatenatematrix)
  587.         
  588.         call  ptk_concatenatematrix(%val(operation), matrix1, matrix2, 
  589. & result)
  590.         
  591.         RETURN
  592.         END
  593.         
  594.         SUBROUTINE ptkf_shift3(shift, operation, matrix)
  595. C /*
  596. C ** \parambegin
  597. C ** \param{REAL}{shift(3)}{shift vector}{IN}
  598. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  599. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{OUT}
  600. C ** \paramend
  601. C ** \blurb{This function computes
  602. C ** a matrix to perform the specified 3D shift and concatenates 
  603. C ** this matrix with \pardesc{matrix} on the basis of \pardesc{operation}.}
  604. C */
  605.         REAL shift(3)
  606.         INTEGER operation
  607.         REAL matrix(4,4)
  608.         external ptk_shift3 !$PRAGMA C(ptk_shift3)
  609.         
  610.         call  ptk_shift3(shift, %val(operation), matrix)
  611.         
  612.         RETURN
  613.         END
  614.         
  615.         SUBROUTINE ptkf_shift(shift, operation, matrix)
  616. C /*
  617. C ** \parambegin
  618. C ** \param{REAL}{shift(2)}{shift vector}{IN}
  619. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  620. C ** \param{REAL}{matrix(3, 3)}{3x3 matrix}{OUT}
  621. C ** \paramend
  622. C ** \blurb{This function computes
  623. C ** a matrix to perform the specified 2D shift and concatenates 
  624. C ** this matrix with \pardesc{matrix} on the basis of \pardesc{operation}.}
  625. C */
  626.         REAL shift(2)
  627.         INTEGER operation
  628.         REAL matrix(3,3)
  629.         external ptk_shift !$PRAGMA C(ptk_shift)
  630.         
  631.         call  ptk_shift(shift, %val(operation), matrix)
  632.         
  633.         RETURN
  634.         END
  635.         
  636.         SUBROUTINE ptkf_scale3(scale, operation, matrix)
  637. C /*
  638. C ** \parambegin
  639. C ** \param{REAL}{scale(3)}{scale vector}{IN}
  640. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  641. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{OUT}
  642. C ** \paramend
  643. C ** \blurb{This function 
  644. C ** computes a matrix to perform the specified 3D scale and concatenates 
  645. C ** this with \pardesc{matrix} on the basis of \pardesc{operation}.}
  646. C */
  647.         REAL scale(3)
  648.         INTEGER operation
  649.         REAL matrix(4,4)
  650.         external ptk_scale3 !$PRAGMA C(ptk_scale3)
  651.         
  652.         call  ptk_scale3(scale, %val(operation), matrix)
  653.         
  654.         RETURN
  655.         END
  656.         
  657.         SUBROUTINE ptkf_scale(scale, operation, matrix)
  658. C /*
  659. C ** \parambegin
  660. C ** \param{REAL}{scale(2)}{scale vector}{IN}
  661. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  662. C ** \param{REAL}{matrix(3, 3)}{3x3 matrix}{OUT}
  663. C ** \paramend
  664. C ** \blurb{This function computes
  665. C **  a matrix to perform the specified 2D scale and concatenates 
  666. C ** this matrix with \pardesc{matrix} on the basis of \pardesc{operation}.}
  667. C */
  668.         REAL scale(2)
  669.         INTEGER operation
  670.         REAL matrix(3,3)
  671.         external ptk_scale !$PRAGMA C(ptk_scale)
  672.         
  673.         call  ptk_scale(scale, %val(operation), matrix)
  674.         
  675.         RETURN
  676.         END
  677.         
  678.         SUBROUTINE ptkf_rotatecs3(costheta, sinetheta, axis, operation, 
  679. & matrix)
  680. C /*
  681. C ** \parambegin
  682. C ** \param{REAL}{costheta}{cosine of angle}{IN}
  683. C ** \param{REAL}{sinetheta}{sine of angle}{IN}
  684. C ** \param{INTEGER}{axis}{x, y or z axis}{IN}
  685. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  686. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{OUT}
  687. C ** \paramend
  688. C ** \blurb{This function computes
  689. C ** a matrix to perform the specified 3D rotation and concatenates 
  690. C ** this matrix with 
  691. C ** \pardesc{matrix} on the basis of \pardesc{operation}.
  692. C ** This form assumes that the rotation is specified
  693. C ** using the $\cos(theta)$ and $\sin(theta)$ terms.
  694. C ** Note that no check is made to ensure that the sum of the squares of these
  695. C ** terms is 1.}
  696. C */
  697.         REAL costheta, sinetheta
  698.         INTEGER axis, operation
  699.         REAL matrix(4,4)
  700.         REAL*8 dpcostheta, dpsinetheta
  701.         external ptk_rotatecs3 !$PRAGMA C(ptk_rotatecs3)
  702.         
  703.         dpcostheta = costheta
  704.         dpsinetheta = sinetheta
  705.         call  ptk_rotatecs3(%val(dpcostheta), %val(dpsinetheta), 
  706. & %val(axis), %val(operation), matrix)
  707.         
  708.         RETURN
  709.         END
  710.         
  711.         SUBROUTINE ptkf_rotatecs(costheta, sinetheta, axis, operation, 
  712. & matrix)
  713. C /*
  714. C ** \parambegin
  715. C ** \param{REAL}{costheta}{cosine of angle}{IN}
  716. C ** \param{REAL}{sinetheta}{sine of angle}{IN}
  717. C ** \param{INTEGER}{axis}{x, y or z axis}{IN}
  718. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  719. C ** \param{REAL}{matrix(3, 3)}{3x3 matrix}{OUT}
  720. C ** \paramend
  721. C ** \blurb{This function computes
  722. C ** a matrix to perform the specified 2D rotation and concatenates 
  723. C ** this matrix with 
  724. C ** \pardesc{matrix} on the basis of \pardesc{operation}.
  725. C ** This form assumes that the rotation is specified
  726. C ** using the $\cos(theta)$ and $\sin(theta)$ terms.
  727. C ** Note that no check is made to ensure that the sum of the squares of these
  728. C ** terms is 1.}
  729. C */
  730.         REAL costheta, sinetheta
  731.         INTEGER axis, operation
  732.         REAL matrix(3,3)
  733.         REAL*8 dpcostheta, dpsinetheta
  734.         external ptk_rotatecs !$PRAGMA C(ptk_rotatecs)
  735.         
  736.         dpcostheta = costheta
  737.         dpsinetheta = sinetheta
  738.         call  ptk_rotatecs(%val(dpcostheta), %val(dpsinetheta), 
  739. & %val(axis), %val(operation), matrix)
  740.         
  741.         RETURN
  742.         END
  743.         
  744.         SUBROUTINE ptkf_rotate3(rotation, axis, operation, matrix)
  745. C /*
  746. C ** \parambegin
  747. C ** \param{REAL}{rotation}{angle in degrees}{IN}
  748. C ** \param{INTEGER}{axis}{x, y or z axis}{IN}
  749. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  750. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{OUT}
  751. C ** \paramend
  752. C ** \blurb{This function computes
  753. C ** a matrix to perform the specified 3D rotation and concatenates 
  754. C ** this matrix with 
  755. C ** \pardesc{matrix} on the basis of \pardesc{operation}.
  756. C ** \pardesc{rotation} is expressed in degrees.}
  757. C */
  758.         REAL rotation
  759.         INTEGER axis, operation
  760.         REAL matrix(4,4)
  761.         REAL*8 dprotation
  762.  
  763.         external ptk_rotate3 !$PRAGMA C(ptk_rotate3)
  764.         
  765.         dprotation = rotation
  766.         call  ptk_rotate3(%val(dprotation), %val(axis), 
  767. & %val(operation), matrix)
  768.         
  769.         RETURN
  770.         END
  771.         
  772.         SUBROUTINE ptkf_rotate(rotation, axis, operation, matrix)
  773. C /*
  774. C ** \parambegin
  775. C ** \param{REAL}{rotation}{angle in degrees}{IN}
  776. C ** \param{INTEGER}{axis}{x, y or z axis}{IN}
  777. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  778. C ** \param{REAL}{matrix(3, 3)}{3x3 matrix}{OUT}
  779. C ** \paramend
  780. C ** \blurb{This function computes
  781. C ** a matrix to perform the specified 2D rotation and concatenates 
  782. C ** this matrix with 
  783. C ** \pardesc{matrix} on the basis of \pardesc{operation}.
  784. C ** \pardesc{rotation} is expressed in degrees.}
  785. C */
  786.         REAL rotation
  787.         INTEGER axis, operation
  788.         REAL matrix(3,3)
  789.         REAL*8 dprotation
  790.         external ptk_rotate !$PRAGMA C(ptk_rotate)
  791.         
  792.         dprotation = rotation
  793.         call  ptk_rotate(%val(dprotation), %val(axis), %val(operation), 
  794. & matrix)
  795.         
  796.         RETURN
  797.         END
  798.         
  799.         SUBROUTINE ptkf_shear3(shearaxis, sheardir, shearfactor, 
  800. & operation, matrix)
  801. C /*
  802. C ** \parambegin
  803. C ** \param{INTEGER}{shearaxis}{x, y or z axis}{IN}
  804. C ** \param{INTEGER}{sheardir}{x, y or z direction}{IN}
  805. C ** \param{REAL}{shearfactor}{shear factor}{IN}
  806. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  807. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{OUT}
  808. C ** \paramend
  809. C ** \blurb{This function computes a matrix to perform the specified 3D
  810. C **  shear and concatenates 
  811. C ** this matrix with 
  812. C ** \pardesc{matrix} on the basis of \pardesc{operation}.
  813. C ** The shear is specified as an amount \pardesc{f} about axis \pardesc{i}
  814. C ** in direction \pardesc{j}.}
  815. C */
  816.         INTEGER shearaxis, sheardir
  817.         REAL shearfactor
  818.         INTEGER operation
  819.         REAL matrix(4,4)
  820.         REAL*8 dpshearfactor
  821.         external ptk_shear3 !$PRAGMA C(ptk_shear3)
  822.         
  823.         dpshearfactor = shearfactor
  824.         call  ptk_shear3(%val(shearaxis), %val(sheardir), 
  825. & %val(dpshearfactor), %val(operation), matrix)
  826.         
  827.         RETURN
  828.         END
  829.         
  830.         SUBROUTINE ptkf_shear(shearaxis, sheardir, shearfactor, 
  831. & operation, matrix)
  832. C /*
  833. C ** \parambegin
  834. C ** \param{INTEGER}{shearaxis}{x or y axis}{IN}
  835. C ** \param{INTEGER}{sheardir}{x or y direction}{IN}
  836. C ** \param{REAL}{shearfactor}{shear factor}{IN}
  837. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  838. C ** \param{REAL}{matrix(3, 3)}{3x3 matrix}{OUT}
  839. C ** \paramend
  840. C ** \blurb{This function computes a matrix to perform the specified 2D
  841. C **  shear and concatenates 
  842. C ** this matrix with 
  843. C ** \pardesc{matrix} on the basis of \pardesc{operation}.
  844. C ** The shear is specified as an amount \pardesc{shearfactor} 
  845. C ** about axis \pardesc{shearaxis}
  846. C ** in direction \pardesc{sheardir}.}
  847. C */
  848.         INTEGER shearaxis, sheardir
  849.         REAL shearfactor
  850.         INTEGER operation
  851.         REAL matrix(3,3)
  852.         REAL*8 dpshearfactor
  853.         external ptk_shear !$PRAGMA C(ptk_shear)
  854.         
  855.         dpshearfactor = shearfactor
  856.         call  ptk_shear(%val(shearaxis), %val(sheardir), 
  857. & %val(dpshearfactor), %val(operation), matrix)
  858.         
  859.         RETURN
  860.         END
  861.         
  862.         SUBROUTINE ptkf_rotatevv3(v1, v2, operation, matrix, error)
  863. C /*
  864. C ** \parambegin
  865. C ** \param{REAL}{v1(3)}{3D vector}{IN}
  866. C ** \param{REAL}{v2(3)}{3D vector}{IN}
  867. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  868. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{OUT}
  869. C ** \param{INTEGER}{error}{error code}{OUT}
  870. C ** \paramend
  871. C ** \blurb{This function computes
  872. C **  a matrix to perform the rotation (about the origin) of the 3D vector
  873. C ** \pardesc{v1} to the 3D vector 
  874. C ** \pardesc{v2}, and concatenates this matrix with 
  875. C ** \pardesc{matrix} on the basis of \pardesc{operation} (\cite{rog:mecg}, 
  876. C **  pages 55--59). If the parameters are invalid, \pardesc{error} is set to 
  877. C ** -1. Otherwise, its value is \pardesc{ptkcpcok}.}
  878. C */
  879.         REAL v1(3), v2(3)
  880.         INTEGER operation
  881.         REAL matrix(4,4)
  882.         INTEGER error
  883.         external ptk_rotatevv3 !$PRAGMA C(ptk_rotatevv3)
  884.         
  885.         call  ptk_rotatevv3(v1, v2, %val(operation), matrix, error)
  886.         
  887.         RETURN
  888.         END
  889.         
  890.         SUBROUTINE ptkf_rotatevv(v1, v2, operation, matrix, error)
  891. C /*
  892. C ** \parambegin
  893. C ** \param{REAL}{v1(2)}{2D vector}{IN}
  894. C ** \param{REAL}{v2(2)}{2D vector}{IN}
  895. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  896. C ** \param{REAL}{matrix(3, 3)}{3x3 matrix}{OUT}
  897. C ** \param{INTEGER}{error}{error code}{OUT}
  898. C ** \paramend
  899. C ** \blurb{This function computes
  900. C **  a matrix to perform the rotation (about the origin) of the 3D vector
  901. C ** \pardesc{v1} to the 3D vector 
  902. C ** \pardesc{v2}, and concatenates this matrix with 
  903. C ** \pardesc{matrix} on the basis of \pardesc{operation} (\cite{rog:mecg}, 
  904. C **  pages 55--59). If the parameters are invalid, \pardesc{error} is set to 
  905. C ** -1. Otherwise, its value is \pardesc{ptkcpcok}.}
  906. C */
  907.         REAL v1(2), v2(2)
  908.         INTEGER operation
  909.         REAL matrix(3,3)
  910.         INTEGER error
  911.         external ptk_rotatevv !$PRAGMA C(ptk_rotatevv)
  912.         
  913.         call  ptk_rotatevv(v1, v2, %val(operation), matrix, error)
  914.         
  915.         RETURN
  916.         END
  917.         
  918.         SUBROUTINE ptkf_rotateline3(p1, p2, theta, operation, matrix, 
  919. & error)
  920. C /*
  921. C ** \parambegin
  922. C ** \param{REAL}{p1(3)}{3D point}{IN}
  923. C ** \param{REAL}{p2(3)}{3D point}{IN}
  924. C ** \param{REAL}{theta}{angle in degrees}{IN}
  925. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  926. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{OUT}
  927. C ** \param{INTEGER}{error}{error code}{OUT}
  928. C ** \paramend
  929. C ** \blurb{This function computes
  930. C ** a matrix to perform a 3D rotation of
  931. C ** \pardesc{theta} degrees
  932. C ** about the line connecting \pardesc{p1} to \pardesc{p2},
  933. C ** and concatenates this matrix with 
  934. C ** \pardesc{matrix} on the basis of \pardesc{operation}.
  935. C ** If the parameters are invalid, \pardesc{error} is set to 
  936. C ** -1. Otherwise, its value is \pardesc{ptkcpcok}.}
  937. C */
  938.         REAL p1(3), p2(3), theta
  939.         INTEGER operation
  940.         REAL matrix(4,4)
  941.         INTEGER error
  942.         REAL*8 dptheta
  943.         external ptk_rotateline3 !$PRAGMA C(ptk_rotateline3)
  944.  
  945.         dptheta = theta
  946.         call  ptk_rotateline3(p1, p2, %val(dptheta), %val(operation), 
  947. & matrix, error)
  948.         
  949.         RETURN
  950.         END
  951.         
  952.         SUBROUTINE ptkf_rotateline(p1, p2, theta, operation, matrix, 
  953. & error)
  954. C /*
  955. C ** \parambegin
  956. C ** \param{REAL}{p1(2)}{2D point}{IN}
  957. C ** \param{REAL}{p2(2)}{2D point}{IN}
  958. C ** \param{REAL}{theta}{angle in degrees}{IN}
  959. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  960. C ** \param{REAL}{matrix(3, 3)}{3x3 matrix}{OUT}
  961. C ** \param{INTEGER}{error}{error code}{OUT}
  962. C ** \paramend
  963. C ** \blurb{This function computes
  964. C ** a matrix to perform a 2D rotation of
  965. C ** \pardesc{theta} degrees
  966. C ** about the line connecting \pardesc{p1} to \pardesc{p2},
  967. C ** and concatenates this matrix with 
  968. C ** \pardesc{matrix} on the basis of \pardesc{operation}.
  969. C ** If the parameters are invalid, \pardesc{error} is set to 
  970. C ** -1. Otherwise, its value is \pardesc{ptkcpcok}.}
  971. C */
  972.         REAL p1(2), p2(2), theta
  973.         INTEGER operation
  974.         REAL matrix(3,3)
  975.         INTEGER error
  976.         REAL*8 dptheta
  977.         external ptk_rotateline !$PRAGMA C(ptk_rotateline)
  978.         
  979.         dptheta = theta
  980.         call  ptk_rotateline(p1, p2, %val(dptheta), %val(operation), 
  981. & matrix, error)
  982.         
  983.         RETURN
  984.         END
  985.         
  986.         SUBROUTINE ptkf_pt3topt4(pt, pt4)
  987. C /*
  988. C ** \parambegin
  989. C ** \param{REAL}{pt(3)}{3D point}{IN}
  990. C ** \param{REAL}{pt4(4)}{4D point}{OUT}
  991. C ** \paramend
  992. C ** \blurb{This function converts the 3D point \pardesc{pt} to a 4D point,
  993. C ** {\tt pt4}. The $w$ coordinate of the 
  994. C ** 4D point is set to $1.0$.}
  995. C */
  996.         REAL pt(3), pt4(4)
  997.  
  998.         pt4(1) = pt(1)
  999.         pt4(2) = pt(2)
  1000.         pt4(3) = pt(3)
  1001.         pt4(4) = 1.0
  1002.         
  1003.         RETURN
  1004.         END
  1005.         
  1006.         SUBROUTINE ptkf_pt4topt3(pt, pt3)
  1007. C /*
  1008. C ** \parambegin
  1009. C ** \param{REAL}{pt(4)}{4D point}{IN}
  1010. C ** \param{REAL}{pt3(3)}{3D point}{OUT}
  1011. C ** \paramend
  1012. C ** \blurb{This function converts the 4D point \pardesc{pt} to a 3D point
  1013. C ** {\tt pt3}, by dividing by $w$.}
  1014. C */
  1015.         REAL pt(4), pt3(3), w
  1016.         LOGICAL ptkf_equal, ans
  1017.   
  1018.         ans = ptkf_equal(pt(4), 0.0)
  1019.         if (ans .eq. .TRUE.) then
  1020.           w = 1.0 / 1.0e-7
  1021.         else
  1022.           w = 1.0 / pt(4)
  1023.         endif
  1024.  
  1025.         pt3(1) = pt(1) * w
  1026.         pt3(2) = pt(2) * w
  1027.         pt3(3) = pt(3) * w
  1028.         
  1029.         RETURN
  1030.         END
  1031.         
  1032.         SUBROUTINE ptkf_transform4(matrix, point, tpoint)
  1033. C /*
  1034. C ** \parambegin
  1035. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{IN}
  1036. C ** \param{REAL}{point(4)}{4D point}{IN}
  1037. C ** \param{REAL}{tpoint(4)}{4D point}{OUT}
  1038. C ** \paramend
  1039. C ** \blurb{This function performs the 4D transformation 
  1040. C ** (that is, with no homogeneous division) of the
  1041. C ** point \pardesc{point} by the $4 \times 4$ matrix
  1042. C ** \pardesc{matrix}, and returns the result in {\tt tpoint}.}
  1043. C */
  1044.         REAL matrix(4,4), point(4), tpoint(4)
  1045.  
  1046.         tpoint(1) = matrix(1, 1) * point(1) + matrix(1, 2) * point(2) + 
  1047. & matrix(1, 3) * point(3) + matrix(1, 4) * point(4)
  1048.         tpoint(2) = matrix(2, 1) * point(1) + matrix(2, 2) * point(2) + 
  1049. & matrix(2, 3) * point(3) + matrix(2, 4) * point(4)
  1050.         tpoint(3) = matrix(3, 1) * point(1) + matrix(3, 2) * point(2) + 
  1051. & matrix(3, 3) * point(3) + matrix(3, 4) * point(4)
  1052.         tpoint(4) = matrix(4, 1) * point(1) + matrix(4, 2) * point(2) + 
  1053. & matrix(4, 3) * point(3) + matrix(4, 4) * point(4)
  1054.         
  1055.         RETURN
  1056.         END
  1057.         
  1058.         SUBROUTINE ptkf_transform3(matrix, point, tpoint)
  1059. C /*
  1060. C ** \parambegin
  1061. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{IN}
  1062. C ** \param{REAL}{point(3)}{3D point}{IN}
  1063. C ** \param{REAL}{tpoint(3)}{3D point}{OUT}
  1064. C ** \paramend
  1065. C ** \blurb{This function transforms the 3D point \pardesc{point} by
  1066. C ** the $4 \times 4$ matrix \pardesc{matrix},
  1067. C ** including homogeneous division. 
  1068. C ** The result is returned in {\tt tpoint}.}
  1069. C */
  1070.         REAL matrix(4,4), point(3), tpoint(3), temp(4)
  1071.  
  1072.         temp(1) = matrix(1, 1) * point(1) + matrix(1, 2) * point(2) + 
  1073. & matrix(1, 3) * point(3) + matrix(1, 4)
  1074.         temp(2) = matrix(2, 1) * point(1) + matrix(2, 2) * point(2) + 
  1075. & matrix(2, 3) * point(3) + matrix(2, 4)
  1076.         temp(3) = matrix(3, 1) * point(1) + matrix(3, 2) * point(2) + 
  1077. & matrix(3, 3) * point(3) + matrix(3, 4)
  1078.         temp(4) = matrix(4, 1) * point(1) + matrix(4, 2) * point(2) + 
  1079. & matrix(4, 3) * point(3) + matrix(4, 4)
  1080.  
  1081.         call ptkf_pt4topt3(temp, tpoint)
  1082.         
  1083.         RETURN
  1084.         END
  1085.         
  1086.         SUBROUTINE ptkf_transform(matrix, point, tpoint)
  1087. C /*
  1088. C ** \parambegin
  1089. C ** \param{REAL}{matrix(3, 3)}{3x3 matrix}{IN}
  1090. C ** \param{REAL}{point(2)}{2D point}{IN}
  1091. C ** \param{REAL}{tpoint(2)}{2D point}{OUT}
  1092. C ** \paramend
  1093. C ** \blurb{This function transforms the 2D point \pardesc{point} by the
  1094. C ** $3 \times 3$ matrix \pardesc{matrix} and returnes the result
  1095. C ** in {\tt tpoint}.}
  1096. C */
  1097.         REAL matrix(3,3), point(2), tpoint(2)
  1098.  
  1099.         tpoint(1) = matrix(1, 1) * point(1) + matrix(1, 2) * point(2) + 
  1100. & matrix(1, 3)
  1101.         tpoint(2) = matrix(2, 1) * point(1) + matrix(2, 2) * point(2) + 
  1102. & matrix(2, 3)
  1103.         
  1104.         RETURN
  1105.         END
  1106.         
  1107.         SUBROUTINE ptkf_matrixtomatrix3(mat, mat3)
  1108. C /*
  1109. C ** \parambegin
  1110. C ** \param{REAL}{mat(3, 3)}{3x3 matrix}{IN}
  1111. C ** \param{REAL}{mat3(4, 4)}{4x4 matrix}{OUT}
  1112. C ** \paramend
  1113. C ** \blurb{This function converts the $3 \times 3$ matrix \pardesc{mat}
  1114. C ** to the $4 \times 4$ matrix \pardesc{mat3}, as follows:
  1115. C ** $$  \left( \begin{array}{ccc}
  1116. C **          a & b & c\\
  1117. C **          d & e & f\\
  1118. C **          g & h & j
  1119. C **        \end{array} \right)
  1120. C ** 
  1121. C ** \rightarrow
  1122. C **
  1123. C ** \left( \begin{array}{cccc}
  1124. C **          a & b & 0 & c\\
  1125. C **          d & e & 0 & f\\
  1126. C **          0 & 0 & 1 & 0\\
  1127. C **          g & h & 0 & j
  1128. C **        \end{array} \right) 
  1129. C ** $$}
  1130. C */
  1131.         REAL mat(3,3), mat3(4,4)
  1132.         external ptk_matrixtomatrix3 !$PRAGMA C(ptk_matrixtomatrix3)
  1133.  
  1134.         call  ptk_matrixtomatrix3(mat, mat3)
  1135.         
  1136.         RETURN
  1137.         END
  1138.         
  1139.         SUBROUTINE ptkf_outputmatrix3(fileptr, matrix, string)
  1140. C /*
  1141. C ** \parambegin
  1142. C ** \param{INTEGER}{fileptr}{file pointer}{OUT}
  1143. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{IN}
  1144. C ** \param{CHARACTER*(*)}{string}{character string}{IN}
  1145. C ** \paramend
  1146. C ** \blurb{This function outputs the $4\times 4$ matrix
  1147. C **  \pardesc{matrix} and the message \pardesc{string}
  1148. C ** to the file specified by \pardesc{fileptr}.}
  1149. C */
  1150.         INTEGER fileptr
  1151.         REAL matrix(4,4)
  1152.         CHARACTER*(*) string
  1153.         external ptk_outputmatrix3 !$PRAGMA C(ptk_outputmatrix3)
  1154.         
  1155.         call  ptk_outputmatrix3(%val(fileptr), matrix, string)
  1156.         
  1157.         RETURN
  1158.         END
  1159.         
  1160.         SUBROUTINE ptkf_box3tobox3(box1, box2, preserve, operation,
  1161. & matrix, error)
  1162. C /*
  1163. C ** \parambegin
  1164. C ** \param{REAL}{box1(6)}{3D volume}{IN}
  1165. C ** \param{REAL}{box2(6)}{3D volume}{IN}
  1166. C ** \param{LOGICAL}{preserve}{preserve aspect ratio}{IN}
  1167. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  1168. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{OUT}
  1169. C ** \param{INTEGER}{error}{error code}{OUT}
  1170. C ** \paramend
  1171. C ** \blurb{This function computes a mapping from one 3D
  1172. C ** box to another -- a 3D window to 3D viewport
  1173. C ** transformation -- and concatenates this transformation
  1174. C ** with \pardesc{matrix} on the
  1175. C ** basis of \pardesc{operation}.If the parameters are invalid,
  1176. C **  \pardesc{error} is set to 
  1177. C ** -1. Otherwise, its value is 0.}
  1178. C */
  1179.         REAL box1(6), box2(6)
  1180.         LOGICAL preserve
  1181.         INTEGER operation
  1182.         REAL matrix(4,4)
  1183.         INTEGER error
  1184.         external ptk_box3tobox3 !$PRAGMA C(ptk_box3tobox3)
  1185.  
  1186.         call  ptk_box3tobox3(box1, box2, %val(preserve), 
  1187. & %val(operation), matrix, error)
  1188.         
  1189.         RETURN
  1190.         END
  1191.         
  1192.         SUBROUTINE ptkf_boxtobox(box1, box2, preserve, operation, 
  1193. & matrix, error)
  1194. C /*
  1195. C ** \parambegin
  1196. C ** \param{REAL}{box1(4)}{2D box}{IN}
  1197. C ** \param{REAL}{box2(4)}{2D box}{IN}
  1198. C ** \param{LOGICAL}{preserve}{preserve aspect ratio}{IN}
  1199. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  1200. C ** \param{REAL}{matrix(3, 3)}{3x3 matrix}{OUT}
  1201. C ** \param{INTEGER}{error}{error code}{OUT}
  1202. C ** \paramend
  1203. C ** \blurb{This function computes
  1204. C **  a mapping from one 2D box to another -- a 2D window to 2D viewport
  1205. C ** transformation ---and concatenates this transformation
  1206. C ** it with \pardesc{matrix} on the
  1207. C ** basis of \pardesc{operation}.
  1208. C ** If the parameters are invalid, \pardesc{error} is set to 
  1209. C ** -1. Otherwise, its value is 0.}
  1210. C */
  1211.         REAL box1(4), box2(4)
  1212.         LOGICAL preserve
  1213.         INTEGER operation
  1214.         REAL matrix(3,3)
  1215.         INTEGER error
  1216.         external ptk_boxtobox  !$PRAGMA C(ptk_boxtobox)
  1217.  
  1218.         call ptk_boxtobox(box1, box2, %val(preserve), %val(operation), 
  1219. & matrix, error)
  1220.         
  1221.         RETURN
  1222.         END
  1223.         
  1224.         SUBROUTINE ptkf_accumulatetran3(fixed, shift, rotx, roty, rotz, 
  1225. & scale,operation, matrix)
  1226. C /*
  1227. C ** \parambegin
  1228. C ** \param{REAL}{fixed(3)}{origin}{IN}
  1229. C ** \param{REAL}{shift(3)}{shift factor}{IN}
  1230. C ** \param{REAL}{rotx}{x rotation}{IN}
  1231. C ** \param{REAL}{rotx}{y rotation}{IN}
  1232. C ** \param{REAL}{rotx}{z rotation}{IN}
  1233. C ** \param{REAL}{scale(3)}{scale factor}{IN}
  1234. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  1235. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{OUT}
  1236. C ** \paramend
  1237. C ** \blurb{This function computes the specified 3D
  1238. C ** shift, scale and rotate transformations, in the order 
  1239. C ** scale, rotate, shift, 
  1240. C ** and then concatenates the resulting transformation
  1241. C ** with the specified matrix on the basis of \pardesc{operation}.}
  1242. C */
  1243.         REAL fixed(3), shift(3), rotx, roty, rotz, scale(3)
  1244.         INTEGER operation
  1245.         REAL matrix(4,4)
  1246.         REAL*8 dprotx, dproty, dprotz
  1247.         external ptk_accumulatetran3 !$PRAGMA C(ptk_accumulatetran3)
  1248.         
  1249.         dprotx = rotx
  1250.         dproty = roty
  1251.         dprotz = rotz
  1252.         call  ptk_accumulatetran3(fixed, shift, %val(dprotx), 
  1253. & %val(dproty), %val(dprotz), scale, %val(operation), matrix)
  1254.         
  1255.         RETURN
  1256.         END
  1257.         
  1258.         SUBROUTINE ptkf_accumulatetran(fixed, shift, rot, scale, 
  1259. & operation, matrix)
  1260. C /*
  1261. C ** \parambegin
  1262. C ** \param{REAL}{fixed(2)}{origin}{IN}
  1263. C ** \param{REAL}{shift(2)}{shift factor}{IN}
  1264. C ** \param{REAL}{rotx}{x rotation}{IN}
  1265. C ** \param{REAL}{scale(2)}{scale factor}{IN}
  1266. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  1267. C ** \param{REAL}{matrix(3, 3)}{3x3 matrix}{OUT}
  1268. C ** \paramend
  1269. C ** \blurb{This function computes the specified 2D
  1270. C ** shift, scale and rotate transformations, in the order 
  1271. C ** scale, rotate, shift, 
  1272. C ** and then concatenates the resulting transformation
  1273. C ** with the specified matrix on the basis of \pardesc{operation}.}
  1274. C */
  1275.         REAL fixed(2), shift(2), rot, scale(2)
  1276.         INTEGER operation
  1277.         REAL matrix(3,3)
  1278.         REAL*8 dprot
  1279.         external ptk_accumulatetran !$PRAGMA C(ptk_accumulatetran)
  1280.         
  1281.         dprot = rot
  1282.         call  ptk_accumulatetran(fixed, shift, %val(dprot), scale, 
  1283. & %val(operation), matrix)
  1284.         
  1285.         RETURN
  1286.         END
  1287.         
  1288.         SUBROUTINE ptkf_evalvieworientation3(viewrefpoint, 
  1289. & viewplanenormal, viewupvector, operation, matrix, error)
  1290. C /*
  1291. C ** \parambegin
  1292. C ** \param{REAL}{viewrefpoint(3)}{view reference point}{IN}
  1293. C ** \param{REAL}{viewplanenormal(3)}{view plane normal}{IN}
  1294. C ** \param{REAL}{viewupvector(3)}{view up vector}{IN}
  1295. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  1296. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{OUT}
  1297. C ** \param{INTEGER}{error}{error code}{OUT}
  1298. C ** \paramend
  1299. C ** \blurb{This function computes 
  1300. C ** a 3D PHIGS view orientation matrix on the basis of
  1301. C ** a specified view reference point (\pardesc{viewrefpoint}), a
  1302. C ** view plane normal (\pardesc{viewplanenormal}) and a view up vector
  1303. C ** (\pardesc{viewupvector}). If the function succeeds,
  1304. C **  \pardesc{error} is set to 
  1305. C **  0. Otherwise,
  1306. C ** \pardesc{error} is 61 if the view plane normal is null,
  1307. C ** 63 if the view up vector is null,
  1308. C ** and 58 if the cross product of the view up vector
  1309. C ** and the view plane normal is null.}
  1310. C */
  1311.         REAL viewrefpoint(3), viewplanenormal(3), viewupvector(3)
  1312.         INTEGER operation
  1313.         REAL matrix(4,4)
  1314.         INTEGER error
  1315.         external ptk_evalvieworientation3 
  1316. & !$PRAGMA C(ptk_evalvieworientation3)
  1317.         
  1318.         call  ptk_evalvieworientation3(viewrefpoint, viewplanenormal, 
  1319. & viewupvector, %val(operation), matrix, error)
  1320.         
  1321.         RETURN
  1322.         END
  1323.         
  1324.         SUBROUTINE ptkf_evalvieworientation(viewrefpoint, viewupvector, 
  1325. & operation, matrix, error)
  1326. C /*
  1327. C ** \parambegin
  1328. C ** \param{REAL}{viewrefpoint(2)}{view reference point}{IN}
  1329. C ** \param{REAL}{viewupvector(2)}{view up vector}{IN}
  1330. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  1331. C ** \param{REAL}{matrix(3, 3)}{3x3 matrix}{OUT}
  1332. C ** \param{INTEGER}{error}{error code}{OUT}
  1333. C ** \paramend
  1334. C ** \blurb{This function computes 
  1335. C ** a 2D PHIGS view orientation matrix on the basis of
  1336. C ** a specified view reference point (\pardesc{viewrefpoint})
  1337. C ** and a view up vector
  1338. C ** (\pardesc{viewupvector}).  If the function succeeds,
  1339. C ** \pardesc{error} is set to 0. Otherwise, 
  1340. C ** \pardesc{error} is 63 if the view up vector is null.}
  1341. C */
  1342.         REAL viewrefpoint(2), viewupvector(2)
  1343.         INTEGER operation
  1344.         REAL matrix(3,3)
  1345.         INTEGER error
  1346.         external ptk_evalvieworientation 
  1347. & !$PRAGMA C(ptk_evalvieworientation)
  1348.  
  1349.         call  ptk_evalvieworientation(viewrefpoint, viewupvector, 
  1350. & %val(operation), matrix, error)
  1351.         
  1352.         RETURN
  1353.         END
  1354.         
  1355.         SUBROUTINE ptkf_evalviewmapping3(wlimits, vlimits, viewtype, 
  1356. & refpoint,vplanedist, operation, matrix, error)
  1357. C /*
  1358. C ** \parambegin
  1359. C ** \param{REAL}{wlimits(6)}{window limits}{IN}
  1360. C ** \param{REAL}{vlimits(6)}{viewport limits}{IN}
  1361. C ** \param{INTEGER}{viewtype}{projection type}{IN}
  1362. C ** \param{REAL}{refpoint(3)}{projection reference point}{IN}
  1363. C ** \param{REAL}{vplanedist}{view plane distance}{IN}
  1364. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  1365. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{OUT}
  1366. C ** \param{INTEGER}{error}{error code}{OUT}
  1367. C ** \paramend
  1368. C ** \blurb{This function evaluates a 3D PHIGS view mapping matrix.
  1369. C ** If the function succeeds,
  1370. C ** \pardesc{error} is set to 0. Otherwise, 
  1371. C ** \pardesc{error} is 
  1372. C ** 329 if the window limits are not valid,
  1373. C ** 336 if the back plane is in front of front plane,
  1374. C ** 330 if the viewport limits are not valid,
  1375. C ** 335 if the projection reference point is on the view plane,
  1376. C ** and 340 if the projection reference point is between front and back planes.}
  1377. C */
  1378.         REAL wlimits(6), vlimits(6)
  1379.         INTEGER viewtype
  1380.         REAL refpoint(3), vplanedist
  1381.         INTEGER operation
  1382.         REAL matrix(4,4)
  1383.         INTEGER error
  1384.         REAL*8 dpvplanedist
  1385.         external ptk_evalviewmapping3 !$PRAGMA C(ptk_evalviewmapping3)
  1386.  
  1387.         dpvplanedist = vplanedist
  1388.         call  ptk_evalviewmapping3(wlimits, vlimits, %val(viewtype), 
  1389. & refpoint,%val(dpvplanedist), %val(operation), matrix, error)
  1390.         
  1391.         RETURN
  1392.         END
  1393.         
  1394.         SUBROUTINE ptkf_evalviewmapping(wlimits, vlimits, operation, 
  1395. & matrix, error)
  1396. C /*
  1397. C ** \parambegin
  1398. C ** \param{REAL}{wlimits(4)}{window limits}{IN}
  1399. C ** \param{REAL}{vlimits(4)}{viewport limits}{IN}
  1400. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  1401. C ** \param{REAL}{matrix(3, 3)}{3x3 matrix}{OUT}
  1402. C ** \param{INTEGER}{error}{error code}{OUT}
  1403. C ** \paramend
  1404. C ** \blurb{This function evaluates a 2d PHIGS view mapping matrix.
  1405. C ** If the function succeeds,
  1406. C ** \pardesc{error} is set to \pardesc{ptkcpcok}. Otherwise, 
  1407. C ** \pardesc{error} is
  1408. C ** 329 if the window limits are not valid,
  1409. C ** and 330 if the viewport limits are not valid.}
  1410. C */
  1411.         REAL wlimits(4), vlimits(4)
  1412.         INTEGER operation
  1413.         REAL matrix(3,3)
  1414.         INTEGER error
  1415.         external ptk_evalviewmapping !$PRAGMA C(ptk_evalviewmapping)
  1416.  
  1417.         call  ptk_evalviewmapping(wlimits, vlimits, %val(operation), 
  1418. & matrix, error)
  1419.         
  1420.         RETURN
  1421.         END
  1422.         
  1423.         SUBROUTINE ptkf_stackmatrix3(matrix)
  1424. C /*
  1425. C ** \parambegin
  1426. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{IN}
  1427. C ** \paramend
  1428. C ** \blurb{This function pushes
  1429. C ** the $4 \times 4$ matrix \pardesc{matrix} onto the transformation stack.}
  1430. C */
  1431.         REAL matrix(4,4)
  1432.         external ptk_stackmatrix3 !$PRAGMA C(ptk_stackmatrix3)
  1433.  
  1434.         call  ptk_stackmatrix3(matrix)
  1435.         
  1436.         RETURN
  1437.         END
  1438.         
  1439.         SUBROUTINE ptkf_stackmatrix(matrix)
  1440. C /*
  1441. C ** \parambegin
  1442. C ** \param{REAL}{matrix(3, 3)}{3x3 matrix}{IN}
  1443. C ** \paramend
  1444. C ** \blurb{This function pushes the $3 \times 3$ matrix \pardesc{matrix}
  1445. C **  onto the transformation stack.}
  1446. C */
  1447.         REAL matrix(3,3)
  1448.         external ptk_stackmatrix !$PRAGMA C(ptk_stackmatrix)
  1449.  
  1450.         call  ptk_stackmatrix(matrix)
  1451.         
  1452.         RETURN
  1453.         END
  1454.         
  1455.         SUBROUTINE ptkf_unstackmatrix3(matrix)
  1456. C /*
  1457. C ** \parambegin
  1458. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{OUT}
  1459. C ** \paramend
  1460. C ** \blurb{This function
  1461. C ** pops a $4 \times 4$  matrix 
  1462. C ** from the transformation stack and returns it in
  1463. C ** \pardesc{matrix}.}
  1464. C */
  1465.         REAL matrix(4,4)
  1466.         external ptk_unstackmatrix3 !$PRAGMA C(ptk_unstackmatrix3)
  1467.  
  1468.         call  ptk_unstackmatrix3(matrix)
  1469.         
  1470.         RETURN
  1471.         END
  1472.         
  1473.         SUBROUTINE ptkf_unstackmatrix(matrix)
  1474. C /*
  1475. C ** \parambegin
  1476. C ** \param{REAL}{matrix(3, 3)}{3x3 matrix}{OUT}
  1477. C ** \paramend
  1478. C ** \blurb{This function pops a $3 \times 3$ matrix
  1479. C ** from the transformation stack and returns it in
  1480. C ** \pardesc{matrix}.}
  1481. C */
  1482.         REAL matrix(3,3)
  1483.         external ptk_unstackmatrix !$PRAGMA C(ptk_unstackmatrix)
  1484.  
  1485.         call  ptk_unstackmatrix(matrix)
  1486.         
  1487.         RETURN
  1488.         END
  1489.         
  1490.         SUBROUTINE ptkf_examinestackmatrix3(matrix)
  1491. C /*
  1492. C ** \parambegin
  1493. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{IN}
  1494. C ** \paramend
  1495. C ** \blurb{This function returns the top entry on the transformation stack.
  1496. C ** The stack is not disturbed.}
  1497. C */
  1498.         REAL matrix(4,4)
  1499.         external ptk_examinestackmatrix3 
  1500. & !$PRAGMA C(ptk_examinestackmatrix3)
  1501.  
  1502.         call  ptk_examinestackmatrix3(matrix)
  1503.         
  1504.         RETURN
  1505.         END
  1506.         
  1507.         SUBROUTINE ptkf_examinestackmatrix(matrix)
  1508. C /*
  1509. C ** \parambegin
  1510. C ** \param{REAL}{matrix(3, 3)}{3x3 matrix}{IN}
  1511. C ** \paramend
  1512. C ** \blurb{This function  returns the top entry on the transformation stack.
  1513. C ** The stack is not disturbed.}
  1514. C */
  1515.         REAL matrix(3,3)
  1516.         external ptk_examinestackmatrix 
  1517. & !$PRAGMA C(ptk_examinestackmatrix)
  1518.  
  1519.         call  ptk_examinestackmatrix(matrix)
  1520.         
  1521.         RETURN
  1522.         END
  1523.         
  1524.         SUBROUTINE ptkf_3ptto3pt(p1, p2, p3, q1, q2, q3, operation, 
  1525. & matrix, error)
  1526. C /*
  1527. C ** \parambegin
  1528. C ** \param{REAL}{p1(3)}{3D point}{IN}
  1529. C ** \param{REAL}{p2(3)}{3D point}{IN}
  1530. C ** \param{REAL}{p3(3)}{3D point}{IN}
  1531. C ** \param{REAL}{q1(3)}{3D point}{IN}
  1532. C ** \param{REAL}{q2(3)}{3D point}{IN}
  1533. C ** \param{REAL}{q3(3)}{3D point}{IN}
  1534. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  1535. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{OUT}
  1536. C ** \param{INTEGER}{error}{error code}{OUT}
  1537. C ** \paramend
  1538. C ** \blurb{This function returns the 3 point to 3 point transformation as
  1539. C ** described in \cite{mort:geom}, pages 353--355.
  1540. C ** The transformation has the following properties:
  1541. C ** \pardesc{p1} is transformed onto \pardesc{q1};
  1542. C ** the vector \pardesc{(p2-p1)} is transformed to be parallel to the vector 
  1543. C ** \pardesc{(q2-q1)};
  1544. C ** the plane containing the three points \pardesc{p1, p2, p3} is
  1545. C ** transformed into  the plane containing \pardesc{q1, q2, q3}.
  1546. C ** The transformation is concatenated with the $4 \times 4$ matrix
  1547. C ** \pardesc{matrix} on the basis of \pardesc{operation}.
  1548. C ** If the parameters are invalid, \pardesc{error} is set to 
  1549. C ** -1. Otherwise, its value is \pardesc{ptkcpcok}.}
  1550. C */
  1551.         REAL p1(3), p2(3), p3(3), q1(3), q2(3), q3(3)
  1552.         INTEGER operation
  1553.         REAL matrix(4,4)
  1554.         INTEGER error
  1555.         external ptk_3ptto3pt  !$PRAGMA C(ptk_3ptto3pt)
  1556.  
  1557.         call  ptk_3ptto3pt(p1, p2, p3, q1, q2, q3, %val(operation), 
  1558. & matrix, error)
  1559.         
  1560.         RETURN
  1561.         END
  1562.         
  1563.         SUBROUTINE ptkf_0to3pt(origin, xdirn, ydirn, operation, matrix)
  1564. C /*
  1565. C ** \parambegin
  1566. C ** \param{REAL}{origin(3)}{origin of axes}{IN}
  1567. C ** \param{REAL}{xdirn(3)}{x direction}{IN}
  1568. C ** \param{REAL}{y dirn(3)}{y direction}{IN}
  1569. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  1570. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{OUT}
  1571. C ** \paramend
  1572. C ** \blurb{This function computes an object transformation which
  1573. C ** maps unit vectors 
  1574. C ** along the $x$, $y$ and $z$ axes onto unit vectors along the
  1575. C ** corresponding axes 
  1576. C ** of the new coordinate system.}
  1577. C */
  1578.         REAL origin(3), xdirn(3), ydirn(3)
  1579.         INTEGER operation
  1580.         REAL matrix(4,4)
  1581.         external ptk_0to3pt !$PRAGMA C(ptk_0to3pt)
  1582.         
  1583.         call  ptk_0to3pt(origin, xdirn, ydirn, %val(operation), matrix)
  1584.         
  1585.         RETURN
  1586.         END
  1587.         
  1588.         SUBROUTINE ptkf_oto3pt(origin, xdirn, ydirn, operation, matrix)
  1589. C /*
  1590. C ** \parambegin
  1591. C ** \param{REAL}{origin(3)}{origin of axes}{IN}
  1592. C ** \param{REAL}{xdirn(3)}{x direction}{IN}
  1593. C ** \param{REAL}{y dirn(3)}{y direction}{IN}
  1594. C ** \param{INTEGER}{operation}{concatenation operation}{IN}
  1595. C ** \param{REAL}{matrix(4, 4)}{4x4 matrix}{OUT}
  1596. C ** \paramend
  1597. C ** \blurb{This function performs the same operation as
  1598. C **  \pardesc{ptk\_0to3pt}, except the name has an \pardesc{o}\ 
  1599. C ** (oh) instead of \pardesc{0}\ (zero). This function is provided for members
  1600. C ** of the Fumbly Fingers Club.}
  1601. C */
  1602.         REAL origin(3), xdirn(3), ydirn(3)
  1603.         INTEGER operation
  1604.         REAL matrix(4,4)
  1605.         external ptk_oto3pt !$PRAGMA C(ptk_oto3pt)        
  1606.  
  1607.         call  ptk_oto3pt(origin, xdirn, ydirn, %val(operation), matrix)
  1608.         
  1609.         RETURN
  1610.         END
  1611.         
  1612.         SUBROUTINE ptkf_invertmatrix3(a, ainverse, error)
  1613. C /*
  1614. C ** \parambegin
  1615. C ** \param{REAL}{a(4, 4)}{4x4 matrix}{IN}
  1616. C ** \param{REAL}{ainverse(4, 4)}{4x4 matrix}{OUT}
  1617. C ** \param{INTEGER}{error}{error code}{OUT}
  1618. C ** \paramend
  1619. C ** \blurb{This function computes the inverse of the $4 \times 4$
  1620. C ** matrix \pardesc{a}, 
  1621. C ** returning the result in \pardesc{ainverse}. 
  1622. C ** If matrix \pardesc{a} is singular, then 
  1623. C ** \pardesc{error} is set to $-1$, and \pardesc{ainverse} is undefined,
  1624. C ** otherwise \pardesc{error} is set to 0.}
  1625. C */
  1626.         REAL a(4,4), ainverse(4,4)
  1627.         INTEGER error
  1628.         external ptk_invertmatrix3 !$PRAGMA C(ptk_invertmatrix3)
  1629.         
  1630.         call  ptk_invertmatrix3(a, ainverse, error)
  1631.         
  1632.         RETURN
  1633.         END
  1634.         
  1635.         SUBROUTINE ptkf_invertmatrix(a, ainverse, error)
  1636. C /*
  1637. C ** \parambegin
  1638. C ** \param{REAL}{a(3, 3)}{3x3 matrix}{IN}
  1639. C ** \param{REAL}{ainverse(3, 3)}{3x3 matrix}{OUT}
  1640. C ** \param{INTEGER}{error}{error code}{OUT}
  1641. C ** \paramend
  1642. C ** \blurb{This function computes the inverse of the $3 \times 3$
  1643. C ** matrix \pardesc{a}, 
  1644. C ** returning the result in \pardesc{ainverse}. 
  1645. C ** If matrix \pardesc{a} is singular, then 
  1646. C ** \pardesc{error} is set to $-1$, and \pardesc{ainverse} is undefined,
  1647. C ** otherwise \pardesc{error} is set to 0.}
  1648. C */
  1649.         REAL a(4,4), ainverse(4,4)
  1650.         INTEGER error
  1651.         external ptk_invertmatrix !$PRAGMA C(ptk_invertmatrix)
  1652.         
  1653.         call  ptk_invertmatrix(a, ainverse, error)
  1654.         
  1655.         RETURN
  1656.         END
  1657.         
  1658. C       end of tran.f 
  1659.